home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / bin / perlbug < prev    next >
Encoding:
Text File  |  2012-12-11  |  52.9 KB  |  1,521 lines
  1. #!/usr/bin/perl
  2.     eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
  3.     if $running_under_some_shell;
  4.  
  5. my $config_tag1 = '5.10.1 - Tue Dec 11 14:36:33 UTC 2012';
  6.  
  7. my $patchlevel_date = 1355234938;
  8. my $patch_tags = '+DEBPKG:debian/arm_thread_stress_timeout +DEBPKG:debian/cpan_config_path +DEBPKG:debian/cpan_definstalldirs +DEBPKG:debian/db_file_ver +DEBPKG:debian/doc_info +DEBPKG:debian/enc2xs_inc +DEBPKG:debian/errno_ver +DEBPKG:debian/extutils_hacks +DEBPKG:debian/fakeroot +DEBPKG:debian/instmodsh_doc +DEBPKG:debian/ld_run_path +DEBPKG:debian/libnet_config_path +DEBPKG:debian/m68k_thread_stress +DEBPKG:debian/mod_paths +DEBPKG:debian/module_build_man_extensions +DEBPKG:debian/perl_synopsis +DEBPKG:debian/prune_libs +DEBPKG:debian/use_gdbm +DEBPKG:fixes/assorted_docs +DEBPKG:fixes/net_smtp_docs +DEBPKG:fixes/processPL +DEBPKG:debian/perlivp +DEBPKG:fixes/pod2man-index-backslash +DEBPKG:debian/disable-zlib-bundling +DEBPKG:fixes/kfreebsd_cppsymbols +DEBPKG:debian/cpanplus_definstalldirs +DEBPKG:debian/cpanplus_config_path +DEBPKG:fixes/kfreebsd-filecopy-pipes +DEBPKG:fixes/anon-tmpfile-dir +DEBPKG:fixes/abstract-sockets +DEBPKG:fixes/hurd_cppsymbols +DEBPKG:fixes/autodie-flock +DEBPKG:fixes/archive-tar-instance-error +DEBPKG:fixes/positive-gpos +DEBPKG:debian/devel-ppport-ia64-optim +DEBPKG:fixes/trie-logic-match +DEBPKG:fixes/hppa-thread-eagain +DEBPKG:fixes/crash-on-undefined-destroy +DEBPKG:fixes/tainted-errno +DEBPKG:fixes/safe-upgrade +DEBPKG:fixes/tell-crash +DEBPKG:fixes/format-write-crash +DEBPKG:fixes/arm-alignment +DEBPKG:fixes/fcgi-test +DEBPKG:fixes/hurd-ccflags +DEBPKG:debian/squelch-locale-warnings +DEBPKG:fixes/lc-numeric-docs +DEBPKG:fixes/lc-numeric-sprintf +DEBPKG:fixes/concat-stack-corruption +DEBPKG:fixes/cgi-multiline-header +DEBPKG:fixes/casing-taint-cve-2011-1487 +DEBPKG:fixes/safe-reval-rdo-cve-2010-1447 +DEBPKG:fixes/encode-heap-overflow +DEBPKG:fixes/digest_eval_hole +DEBPKG:fixes/unregister_signal_handler +DEBPKG:fixes/CVE-2012-5195 +DEBPKG:fixes/CVE-2012-5526 +DEBPKG:fixes/storable-security-warning +DEBPKG:patchlevel ';
  9. my @patches = (
  10.     'DEBPKG:debian/arm_thread_stress_timeout - http://bugs.debian.org/501970 Raise the timeout of ext/threads/shared/t/stress.t to accommodate slower build hosts',
  11.     'DEBPKG:debian/cpan_config_path - Set location of CPAN::Config to /etc/perl as /usr may not be writable.',
  12.     'DEBPKG:debian/cpan_definstalldirs - Provide a sensible INSTALLDIRS default for modules installed from CPAN.',
  13.     'DEBPKG:debian/db_file_ver - http://bugs.debian.org/340047 Remove overly restrictive DB_File version check.',
  14.     'DEBPKG:debian/doc_info - Replace generic man(1) instructions with Debian-specific information.',
  15.     'DEBPKG:debian/enc2xs_inc - http://bugs.debian.org/290336 Tweak enc2xs to follow symlinks and ignore missing @INC directories.',
  16.     'DEBPKG:debian/errno_ver - http://bugs.debian.org/343351 Remove Errno version check due to upgrade problems with long-running processes.',
  17.     'DEBPKG:debian/extutils_hacks - Various debian-specific ExtUtils changes',
  18.     'DEBPKG:debian/fakeroot - Postpone LD_LIBRARY_PATH evaluation to the binary targets.',
  19.     'DEBPKG:debian/instmodsh_doc - Debian policy doesn\'t install .packlist files for core or vendor.',
  20.     'DEBPKG:debian/ld_run_path - Remove standard libs from LD_RUN_PATH as per Debian policy.',
  21.     'DEBPKG:debian/libnet_config_path - Set location of libnet.cfg to /etc/perl/Net as /usr may not be writable.',
  22.     'DEBPKG:debian/m68k_thread_stress - http://bugs.debian.org/495826 Disable some threads tests on m68k for now due to missing TLS.',
  23.     'DEBPKG:debian/mod_paths - Tweak @INC ordering for Debian',
  24.     'DEBPKG:debian/module_build_man_extensions - http://bugs.debian.org/479460 Adjust Module::Build manual page extensions for the Debian Perl policy',
  25.     'DEBPKG:debian/perl_synopsis - http://bugs.debian.org/278323 Rearrange perl.pod',
  26.     'DEBPKG:debian/prune_libs - http://bugs.debian.org/128355 Prune the list of libraries wanted to what we actually need.',
  27.     'DEBPKG:debian/use_gdbm - Explicitly link against -lgdbm_compat in ODBM_File/NDBM_File. ',
  28.     'DEBPKG:fixes/assorted_docs - http://bugs.debian.org/443733 [384f06a] Math::BigInt::CalcEmu documentation grammar fix',
  29.     'DEBPKG:fixes/net_smtp_docs - http://bugs.debian.org/100195 [rt.cpan.org #36038] Document the Net::SMTP \'Port\' option',
  30.     'DEBPKG:fixes/processPL - http://bugs.debian.org/357264 [rt.cpan.org #17224] Always use PERLRUNINST when building perl modules.',
  31.     'DEBPKG:debian/perlivp - http://bugs.debian.org/510895 Make perlivp skip include directories in /usr/local',
  32.     'DEBPKG:fixes/pod2man-index-backslash - http://bugs.debian.org/521256 Escape backslashes in .IX entries',
  33.     'DEBPKG:debian/disable-zlib-bundling - Disable zlib bundling in Compress::Raw::Zlib',
  34.     'DEBPKG:fixes/kfreebsd_cppsymbols - http://bugs.debian.org/533098 [3b910a0] Add gcc predefined macros to $Config{cppsymbols} on GNU/kFreeBSD.',
  35.     'DEBPKG:debian/cpanplus_definstalldirs - http://bugs.debian.org/533707 Configure CPANPLUS to use the site directories by default.',
  36.     'DEBPKG:debian/cpanplus_config_path - Save local versions of CPANPLUS::Config::System into /etc/perl.',
  37.     'DEBPKG:fixes/kfreebsd-filecopy-pipes - http://bugs.debian.org/537555 [16f708c] Fix File::Copy::copy with pipes on GNU/kFreeBSD',
  38.     'DEBPKG:fixes/anon-tmpfile-dir - http://bugs.debian.org/528544 [perl #66452] Honor TMPDIR when open()ing an anonymous temporary file',
  39.     'DEBPKG:fixes/abstract-sockets - http://bugs.debian.org/329291 [89904c0] Add support for Abstract namespace sockets.',
  40.     'DEBPKG:fixes/hurd_cppsymbols - http://bugs.debian.org/544307 [eeb92b7] Add gcc predefined macros to $Config{cppsymbols} on GNU/Hurd.',
  41.     'DEBPKG:fixes/autodie-flock - http://bugs.debian.org/543731 Allow for flock returning EAGAIN instead of EWOULDBLOCK on linux/parisc',
  42.     'DEBPKG:fixes/archive-tar-instance-error - http://bugs.debian.org/539355 [rt.cpan.org #48879] Separate Archive::Tar instance error strings from each other',
  43.     'DEBPKG:fixes/positive-gpos - http://bugs.debian.org/545234 [perl #69056] [c584a96] Fix \\\\G crash on first match',
  44.     'DEBPKG:debian/devel-ppport-ia64-optim - http://bugs.debian.org/548943 Work around an ICE on ia64',
  45.     'DEBPKG:fixes/trie-logic-match - http://bugs.debian.org/552291 [perl #69973] [0abd0d7] Fix a DoS in Unicode processing [CVE-2009-3626]',
  46.     'DEBPKG:fixes/hppa-thread-eagain - http://bugs.debian.org/554218 make the threads-shared test suite more robust, fixing failures on hppa',
  47.     'DEBPKG:fixes/crash-on-undefined-destroy - http://bugs.debian.org/564074 [perl #71952] [1f15e67] Fix a NULL pointer dereference when looking for a DESTROY method',
  48.     'DEBPKG:fixes/tainted-errno - http://bugs.debian.org/574129 [perl #61976] [be1cf43] fix an errno stringification bug in taint mode',
  49.     'DEBPKG:fixes/safe-upgrade - http://bugs.debian.org/582978 Upgrade Safe.pm to 2.25, fixing CVE-2010-1974',
  50.     'DEBPKG:fixes/tell-crash - http://bugs.debian.org/578577 [f4817f3] Fix a tell() crash on bad arguments.',
  51.     'DEBPKG:fixes/format-write-crash - http://bugs.debian.org/579537 [perl #22977] [421f30e] Fix a crash in format/write',
  52.     'DEBPKG:fixes/arm-alignment - http://bugs.debian.org/289884 [f1c7503] Prevent gcc from optimizing the alignment test away on armel',
  53.     'DEBPKG:fixes/fcgi-test - Fix a failure in CGI/t/fast.t when FCGI is installed',
  54.     'DEBPKG:fixes/hurd-ccflags - http://bugs.debian.org/587901 Make hints/gnu.sh append to $ccflags rather than overriding them',
  55.     'DEBPKG:debian/squelch-locale-warnings - http://bugs.debian.org/508764 Squelch locale warnings in Debian package maintainer scripts',
  56.     'DEBPKG:fixes/lc-numeric-docs - http://bugs.debian.org/379329 [perl #78452] [903eb63] LC_NUMERIC documentation fixes',
  57.     'DEBPKG:fixes/lc-numeric-sprintf - http://bugs.debian.org/601549 [perl #78632] [b3fd614] Fix sprintf not to ignore LC_NUMERIC with constants',
  58.     'DEBPKG:fixes/concat-stack-corruption - http://bugs.debian.org/596105 [perl #78674] [e3393f5] Fix stack pointer corruption in pp_concat() with \'use encoding\'',
  59.     'DEBPKG:fixes/cgi-multiline-header - http://bugs.debian.org/606995 [CVE-2010-2761 CVE-2010-4410 CVE-2010-4411] CGI.pm MIME boundary and multiline header vulnerabilities',
  60.     'DEBPKG:fixes/casing-taint-cve-2011-1487 - http://bugs.debian.org/622817 [perl #87336] fix unwanted taint laundering in lc(), uc() et al.',
  61.     'DEBPKG:fixes/safe-reval-rdo-cve-2010-1447 - [PATCH] Wrap by default coderefs returned by rdo and reval',
  62.     'DEBPKG:fixes/encode-heap-overflow - [PATCH] Fix decode_xs n-byte heap-overflow security bug in',
  63.     'DEBPKG:fixes/digest_eval_hole - Close the eval \\"require $module\\" security hole in',
  64.     'DEBPKG:fixes/unregister_signal_handler - [PATCH] main: Unregister signal handler before destroying my_perl',
  65.     'DEBPKG:fixes/CVE-2012-5195 - avoid calling memset with a negative count',
  66.     'DEBPKG:fixes/CVE-2012-5526 - [PATCH 1/4] CR escaping for P3P header',
  67.     'DEBPKG:fixes/storable-security-warning - [PATCH] add a note about security concerns in Storable',
  68.     'DEBPKG:patchlevel - http://bugs.debian.org/567489 List packaged patches for 5.10.1-17squeeze4 in patchlevel.h'
  69. );
  70.  
  71. use warnings;
  72. no warnings 'once'; # Eventually, the $::opt_ stuff should get cleaned up
  73. use strict;
  74. use Config;
  75. use File::Spec;        # keep perlbug Perl 5.005 compatible
  76. use Getopt::Std;
  77. use File::Basename 'basename';
  78.  
  79. sub paraprint;
  80.  
  81. BEGIN {
  82.     eval { require Mail::Send;};
  83.     $::HaveSend = ($@ eq "");
  84.     eval { require Mail::Util; } ;
  85.     $::HaveUtil = ($@ eq "");
  86.     # use secure tempfiles wherever possible
  87.     eval { require File::Temp; };
  88.     $::HaveTemp = ($@ eq "");
  89.     eval { require Module::CoreList; };
  90.     $::HaveCoreList = ($@ eq "");
  91. };
  92.  
  93. my $Version = "1.39";
  94.  
  95. # Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
  96. # Changed in 1.07 to see more sendmail execs, and added pipe output.
  97. # Changed in 1.08 to use correct address for sendmail.
  98. # Changed in 1.09 to close the REP file before calling it up in the editor.
  99. #                 Also removed some old comments duplicated elsewhere.
  100. # Changed in 1.10 to run under VMS without Mail::Send; also fixed
  101. #                 temp filename generation.
  102. # Changed in 1.11 to clean up some text and removed Mail::Send deactivator.
  103. # Changed in 1.12 to check for editor errors, make save/send distinction
  104. #                 clearer and add $ENV{REPLYTO}.
  105. # Changed in 1.13 to hopefully make it more difficult to accidentally
  106. #                 send mail
  107. # Changed in 1.14 to make the prompts a little more clear on providing
  108. #                 helpful information. Also let file read fail gracefully.
  109. # Changed in 1.15 to add warnings to stop people using perlbug for non-bugs.
  110. #                 Also report selected environment variables.
  111. # Changed in 1.16 to include @INC, and allow user to re-edit if no changes.
  112. # Changed in 1.17 Win32 support added.  GSAR 97-04-12
  113. # Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18
  114. # Changed in 1.19 '-ok' default not '-v'
  115. #                 add local patch information
  116. #                 warn on '-ok' if this is an old system; add '-okay'
  117. # Changed in 1.20 Added patchlevel.h reading and version/config checks
  118. # Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05
  119. # Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10
  120. # Changed in 1.23 Restore -ok(ay): say 'success'; don't prompt
  121. # Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01
  122. # Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12
  123. # Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15
  124. # Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27
  125. # Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000
  126. # Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000
  127. # Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000
  128. # Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000
  129. # Changed in 1.32 Use File::Spec->tmpdir TJENNESS 20-08-2000
  130. # Changed in 1.33 Don't require -t STDOUT for -ok.
  131. # Changed in 1.34 Added Message-Id RFOLEY 18-06-2002 
  132. # Changed in 1.35 Use File::Temp (patch from Solar Designer) NWCLARK 28-02-2004
  133. # Changed in 1.36 Initial Module::CoreList support Alexandr Ciornii 11-07-2007
  134. # Changed in 1.37 Killed some string evals, rewrote most prose JESSE 2008-06-08
  135. # Changed in 1.38 Actually enforce the CoreList check,
  136. #                 Record the module the user enters if they do so
  137. #                 Refactor prompts to use common code           JESSE 2008-06-08
  138. # Changed in 1.39 Trap mail sending failures (simple ones) so   JESSE 2008-06-08
  139. #                 users might be able to recover their bug reports
  140. #                 Refactor mail sending routines
  141. #                 Unify message building code
  142. #                 Unify message header building
  143. #                 Fix "module" prompting to not squish "category" prompting 
  144. #                 use warnings; (except 'once' warnings)
  145. #                 Unified report fingerprint/change detection code
  146. #                 Removed some labeled 'gotos'
  147. #TODO:
  148. #       make sure failure (transmission-wise) of Mail::Send is accounted for.
  149. #       (This may work now. Unsure of the original author's issue -JESSE 2008-06-08)
  150. #       - Test -b option
  151.  
  152. my( $file, $usefile, $cc, $address, $bugaddress, $testaddress, $thanksaddress,
  153.     $filename, $messageid, $domain, $subject, $from, $verbose, $ed, $outfile,
  154.     $fh, $me, $body, $andcc, %REP, $ok, $thanks, $progname,
  155.     $Is_MacOS, $Is_MSWin32, $Is_Linux, $Is_VMS, $Is_OpenBSD,
  156.     $report_about_module, $category, $severity,
  157.  
  158. );
  159.  
  160. my $perl_version = $^V ? sprintf("%vd", $^V) : $];
  161.  
  162. my $config_tag2 = "$perl_version - $Config{cf_time}";
  163.  
  164. Init();
  165.  
  166. if ($::opt_h) { Help(); exit; }
  167. if ($::opt_d) { Dump(*STDOUT); exit; }
  168. if (!-t STDIN && !($ok and not $::opt_n)) {
  169.     paraprint <<"EOF";
  170. Please use $progname interactively. If you want to
  171. include a file, you can use the -f switch.
  172. EOF
  173.     die "\n";
  174. }
  175.  
  176. Query();
  177. Edit() unless $usefile || ($ok and not $::opt_n);
  178. NowWhat();
  179. if ($outfile) {
  180.     save_message_to_disk($outfile);
  181. } else {
  182.     Send();
  183.     if ($thanks) {
  184.     print "\nThank you for taking the time to send a thank-you message!\n\n";
  185.     } else {
  186.     print "\nThank you for taking the time to file a bug report!\n\n";
  187.     }
  188. }
  189.  
  190. exit;
  191.  
  192. sub ask_for_alternatives { # (category|severity)
  193.     my $name = shift;
  194.     my %alts = (
  195.     'category' => {
  196.         'default' => 'core',
  197.         'ok'      => 'install',
  198.         # Inevitably some of these will end up in RT whatever we do:
  199.         'thanks'  => 'thanks',
  200.         'opts'    => [qw(core docs install library utilities)], # patch, notabug
  201.     },
  202.     'severity' => {
  203.         'default' => 'low',
  204.         'ok'      => 'none',
  205.         'thanks'  => 'none',
  206.         'opts'    => [qw(critical high medium low wishlist none)], # zero
  207.     },
  208.     );
  209.     die "Invalid alternative ($name) requested\n" unless grep(/^$name$/, keys %alts);
  210.     my $alt = "";
  211.     my $what = $ok || $thanks;
  212.     if ($what) {
  213.     $alt = $alts{$name}{$what};
  214.     } else {
  215.      my @alts = @{$alts{$name}{'opts'}};
  216.     print "\n\n";
  217.     paraprint <<EOF;
  218. Please pick a $name from the following list:
  219.  
  220.     @alts
  221. EOF
  222.     my $err = 0;
  223.     do {
  224.         if ($err++ > 5) {
  225.         die "Invalid $name: aborting.\n";
  226.         }
  227.         $alt = _prompt('', "\u$name", $alts{$name}{'default'});
  228.         $alt ||= $alts{$name}{'default'};
  229.     } while !((($alt) = grep(/^$alt/i, @alts)));
  230.     }
  231.     lc $alt;
  232. }
  233.  
  234. sub Init {
  235.     # -------- Setup --------
  236.  
  237.     $Is_MSWin32 = $^O eq 'MSWin32';
  238.     $Is_VMS = $^O eq 'VMS';
  239.     $Is_Linux = lc($^O) eq 'linux';
  240.     $Is_OpenBSD = lc($^O) eq 'openbsd';
  241.     $Is_MacOS = $^O eq 'MacOS';
  242.  
  243.     @ARGV = split m/\s+/,
  244.         MacPerl::Ask('Provide command line args here (-h for help):')
  245.         if $Is_MacOS && $MacPerl::Version =~ /App/;
  246.  
  247.     if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:T")) { Help(); exit; };
  248.  
  249.     # This comment is needed to notify metaconfig that we are
  250.     # using the $perladmin, $cf_by, and $cf_time definitions.
  251.  
  252.     # -------- Configuration ---------
  253.  
  254.     # perlbug address
  255.     $bugaddress = 'perlbug@perl.org';
  256.  
  257.     # Test address
  258.     $testaddress = 'perlbug-test@perl.org';
  259.  
  260.     # Thanks address
  261.     $thanksaddress = 'perl-thanks@perl.org';
  262.  
  263.     if (basename ($0) =~ /^perlthanks/i) {
  264.     # invoked as perlthanks
  265.     $::opt_T = 1;
  266.     $::opt_C = 1; # don't send a copy to the local admin
  267.     }
  268.  
  269.     if ($::opt_T) {
  270.     $thanks = 'thanks';
  271.     }
  272.     
  273.     $progname = $thanks ? 'perlthanks' : 'perlbug';
  274.     # Target address
  275.     $address = $::opt_a || ($::opt_t ? $testaddress
  276.                 : $thanks ? $thanksaddress : $bugaddress);
  277.  
  278.     # Users address, used in message and in Reply-To header
  279.     $from = $::opt_r || "";
  280.  
  281.     # Include verbose configuration information
  282.     $verbose = $::opt_v || 0;
  283.  
  284.     # Subject of bug-report message
  285.     $subject = $::opt_s || "";
  286.  
  287.     # Send a file
  288.     $usefile = ($::opt_f || 0);
  289.  
  290.     # File to send as report
  291.     $file = $::opt_f || "";
  292.  
  293.     # File to output to
  294.     $outfile = $::opt_F || "";
  295.  
  296.     # Body of report
  297.     $body = $::opt_b || "";
  298.     
  299.     # Editor
  300.     $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
  301.     || ($Is_VMS && "edit/tpu")
  302.     || ($Is_MSWin32 && "notepad")
  303.     || ($Is_MacOS && '')
  304.     || "vi";
  305.  
  306.     # Not OK - provide build failure template by finessing OK report
  307.     if ($::opt_n) {
  308.     if (substr($::opt_n, 0, 2) eq 'ok' )    {
  309.         $::opt_o = substr($::opt_n, 1);
  310.     } else {
  311.         Help();
  312.         exit();
  313.     }
  314.     }
  315.  
  316.     # OK - send "OK" report for build on this system
  317.     $ok = '';
  318.     if ($::opt_o) {
  319.     if ($::opt_o eq 'k' or $::opt_o eq 'kay') {
  320.         my $age = time - $patchlevel_date;
  321.         if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) {
  322.         my $date = localtime $patchlevel_date;
  323.         print <<"EOF";
  324. "perlbug -ok" and "perlbug -nok" do not report on Perl versions which
  325. are more than 60 days old.  This Perl version was constructed on
  326. $date.  If you really want to report this, use
  327. "perlbug -okay" or "perlbug -nokay".
  328. EOF
  329.         exit();
  330.         }
  331.         # force these options
  332.         unless ($::opt_n) {
  333.         $::opt_S = 1; # don't prompt for send
  334.         $::opt_b = 1; # we have a body
  335.         $body = "Perl reported to build OK on this system.\n";
  336.         }
  337.         $::opt_C = 1; # don't send a copy to the local admin
  338.         $::opt_s = 1; # we have a subject line
  339.         $subject = ($::opt_n ? 'Not ' : '')
  340.             . "OK: perl $perl_version ${patch_tags}on"
  341.             ." $::Config{'archname'} $::Config{'osvers'} $subject";
  342.         $ok = 'ok';
  343.     } else {
  344.         Help();
  345.         exit();
  346.     }
  347.     }
  348.  
  349.     # Possible administrator addresses, in order of confidence
  350.     # (Note that cf_email is not mentioned to metaconfig, since
  351.     # we don't really want it. We'll just take it if we have to.)
  352.     #
  353.     # This has to be after the $ok stuff above because of the way
  354.     # that $::opt_C is forced.
  355.     $cc = $::opt_C ? "" : (
  356.     $::opt_c || $::Config{'perladmin'}
  357.     || $::Config{'cf_email'} || $::Config{'cf_by'}
  358.     );
  359.  
  360.     if ($::HaveUtil) {
  361.         $domain = Mail::Util::maildomain();
  362.     } elsif ($Is_MSWin32) {
  363.         $domain = $ENV{'USERDOMAIN'};
  364.     } else {
  365.         require Sys::Hostname;
  366.         $domain = Sys::Hostname::hostname();
  367.     }
  368.  
  369.     # Message-Id - rjsf
  370.     $messageid = "<$::Config{'version'}_${$}_".time."\@$domain>"; 
  371.  
  372.     # My username
  373.     $me = $Is_MSWin32 ? $ENV{'USERNAME'}
  374.         : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'}
  375.         : $Is_MacOS ? $ENV{'USER'}
  376.         : eval { getpwuid($<) };    # May be missing
  377.  
  378.     $from = $::Config{'cf_email'}
  379.        if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me &&
  380.                ($me eq $::Config{'cf_by'});
  381. } # sub Init
  382.  
  383. sub Query {
  384.     # Explain what perlbug is
  385.     unless ($ok) {
  386.     if ($thanks) {
  387.         paraprint <<'EOF';
  388. This program provides an easy way to send a thank-you message back to the
  389. authors and maintainers of perl.
  390.  
  391. If you wish to submit a bug report, please run it without the -T flag
  392. (or run the program perlbug rather than perlthanks)
  393. EOF
  394.     } else {
  395.         paraprint <<"EOF";
  396. This program provides an easy way to create a message reporting a
  397. bug in the core perl distribution (along with tests or patches)
  398. to the volunteers who maintain perl at $address.  To send a thank-you
  399. note to $thanksaddress instead of a bug report, please run 'perlthanks'.
  400.  
  401. Please do not use $0 to send test messages, test whether perl
  402. works, or to report bugs in perl modules from CPAN.
  403.  
  404. For help using perl, try posting to the Usenet newsgroup 
  405. comp.lang.perl.misc.
  406. EOF
  407.     }
  408.     }
  409.  
  410.     # Prompt for subject of message, if needed
  411.     
  412.     if ($subject && TrivialSubject($subject)) {
  413.     $subject = '';
  414.     }
  415.  
  416.     unless ($subject) {
  417.         print 
  418. "First of all, please provide a subject for the message.\n";
  419.     if ( not $thanks)  {
  420.         paraprint <<EOF;
  421. This should be a concise description of your bug or problem
  422. which will help the volunteers working to improve perl to categorize
  423. and resolve the issue.  Be as specific and descriptive as
  424. you can. A subject like "perl bug" or "perl problem" will make it
  425. much less likely that your issue gets the attention it deserves.
  426. EOF
  427.     }
  428.  
  429.     my $err = 0;
  430.     do {
  431.         $subject = _prompt('','Subject');
  432.         if ($err++ == 5) {
  433.         if ($thanks) {
  434.             $subject = 'Thanks for Perl';
  435.         } else {
  436.             die "Aborting.\n";
  437.         }
  438.         }
  439.     } while (TrivialSubject($subject));
  440.     }
  441.  
  442.     # Prompt for return address, if needed
  443.     unless ($from) {
  444.     # Try and guess return address
  445.     my $guess;
  446.  
  447.     $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || '';
  448.         if ($Is_MacOS) {
  449.             require Mac::InternetConfig;
  450.             $guess = $Mac::InternetConfig::InternetConfig{
  451.                 Mac::InternetConfig::kICEmail()
  452.             };
  453.         }
  454.  
  455.     unless ($guess) {
  456.         # move $domain to where we can use it elsewhere    
  457.         if ($domain) {
  458.         if ($Is_VMS && !$::Config{'d_socket'}) {
  459.             $guess = "$domain\:\:$me";
  460.         } else {
  461.             $guess = "$me\@$domain" if $domain;
  462.         }
  463.         }
  464.     }
  465.  
  466.     if ($guess) {
  467.         unless ($ok) {
  468.         paraprint <<EOF;
  469. Perl's developers may need your email address to contact you for
  470. further information about your issue or to inform you when it is
  471. resolved.  If the default shown is not your email address, please
  472. correct it.
  473. EOF
  474.         }
  475.     } else {
  476.         paraprint <<EOF;
  477. Please enter your full internet email address so that Perl's
  478. developers can contact you with questions about your issue or to
  479. inform you that it has been resolved.
  480. EOF
  481.     }
  482.  
  483.     if ($ok && $guess) {
  484.         # use it
  485.         $from = $guess;
  486.     } else {
  487.         # verify it
  488.         $from = _prompt('','Your address',$guess);
  489.         $from = $guess if $from eq '';
  490.     }
  491.     }
  492.  
  493.     if ($from eq $cc or $me eq $cc) {
  494.     # Try not to copy ourselves
  495.     $cc = "yourself";
  496.     }
  497.  
  498.     # Prompt for administrator address, unless an override was given
  499.     if( !$::opt_C and !$::opt_c ) {
  500.     my $description =  <<EOF;
  501. $0 can send a copy of this report to your local perl
  502. administrator.  If the address below is wrong, please correct it,
  503. or enter 'none' or 'yourself' to not send a copy.
  504. EOF
  505.     my $entry = _prompt($description, "Local perl administrator", $cc);
  506.  
  507.     if ($entry ne "") {
  508.         $cc = $entry;
  509.         $cc = '' if $me eq $cc;
  510.     }
  511.     }
  512.  
  513.     $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i;
  514.     if ($cc) { 
  515.         $andcc = " and $cc" 
  516.     } else {
  517.         $andcc = ''
  518.     }
  519.  
  520.     # Prompt for editor, if no override is given
  521. editor:
  522.     unless ($::opt_e || $::opt_f || $::opt_b) {
  523.  
  524.     my $description;
  525.  
  526.     chomp (my $common_end = <<"EOF");
  527. You will probably want to use a text editor to enter the body of
  528. your report. If "$ed" is the editor you want to use, then just press
  529. Enter, otherwise type in the name of the editor you would like to
  530. use.
  531.  
  532. If you have already composed the body of your report, you may enter
  533. "file", and $0 will prompt you to enter the name of the file
  534. containing your report.
  535. EOF
  536.  
  537.     if ($thanks) {
  538.         $description = <<"EOF";
  539. It's now time to compose your thank-you message.
  540.  
  541. Some information about your local perl configuration will automatically
  542. be included at the end of your message, because we're curious about
  543. the different ways that people build and use perl. If you'd rather
  544. not share this information, you're welcome to delete it.
  545.  
  546. $common_end
  547. EOF
  548.     } else {
  549.         $description =  <<"EOF";
  550. It's now time to compose your bug report. Try to make the report
  551. concise but descriptive. Please include any detail which you think
  552. might be relevant or might help the volunteers working to improve
  553. perl. If you are reporting something that does not work as you think
  554. it should, please try to include examples of the actual result and of
  555. what you expected.
  556.  
  557. Some information about your local perl configuration will automatically
  558. be included at the end of your report. If you are using an unusual
  559. version of perl, it would be useful if you could confirm that you
  560. can replicate the problem on a standard build of perl as well.
  561.  
  562. $common_end
  563. EOF
  564.     }
  565.  
  566.     my $entry = _prompt($description, "Editor", $ed);
  567.     $usefile = 0;
  568.     if ($entry eq "file") {
  569.         $usefile = 1;
  570.     } elsif ($entry ne "") {
  571.         $ed = $entry;
  572.     }
  573.     }
  574.     if ($::HaveCoreList && !$ok && !$thanks) {
  575.     my $description =  <<EOF;
  576. If your bug is about a Perl module rather than a core language
  577. feature, please enter its name here. If it's not, just hit Enter
  578. to skip this question.
  579. EOF
  580.  
  581.     my $entry = '';
  582.     while ($entry eq '') {
  583.         $entry = _prompt($description, 'Module');
  584.         my $first_release = Module::CoreList->first_release($entry);
  585.         if ($entry and not $first_release) {
  586.         paraprint <<EOF;
  587. $entry is not a "core" Perl module. Please check that you entered
  588. its name correctly. If it is correct, quit this program, try searching
  589. for $entry on http://rt.cpan.org, and report your issue there.
  590. EOF
  591.  
  592.             $entry = '';
  593.         } elsif ($entry) {
  594.             $category ||= 'library';
  595.             $report_about_module = $entry;
  596.             last;
  597.         } else {
  598.             last;
  599.         }
  600.     }
  601.     }
  602.  
  603.     # Prompt for category of bug
  604.     $category ||= ask_for_alternatives('category');
  605.  
  606.     # Prompt for severity of bug
  607.     $severity ||= ask_for_alternatives('severity');
  608.  
  609.     # Generate scratch file to edit report in
  610.     $filename = filename();
  611.  
  612.     # Prompt for file to read report from, if needed
  613.     if ($usefile and !$file) {
  614. filename:
  615.     my $description = <<EOF;
  616. What is the name of the file that contains your report?
  617. EOF
  618.     my $entry = _prompt($description, "Filename");
  619.  
  620.     if ($entry eq "") {
  621.         paraprint <<EOF;
  622. It seems you didn't enter a filename. Please choose to use a text
  623. editor or enter a filename.
  624. EOF
  625.         goto editor;
  626.     }
  627.  
  628.     unless (-f $entry and -r $entry) {
  629.         paraprint <<EOF;
  630. '$entry' doesn't seem to be a readable file.  You may have mistyped
  631. its name or may not have permission to read it.
  632.  
  633. If you don't want to use a file as the content of your report, just
  634. hit Enter and you'll be able to select a text editor instead.
  635. EOF
  636.         goto filename;
  637.     }
  638.     $file = $entry;
  639.     }
  640.  
  641.     # Generate report
  642.     open(REP,">$filename") or die "Unable to create report file '$filename': $!\n";
  643.     my $reptype = !$ok ? ($thanks ? 'thank-you' : 'bug')
  644.     : $::opt_n ? "build failure" : "success";
  645.  
  646.     print REP <<EOF;
  647. This is a $reptype report for perl from $from,
  648. generated with the help of perlbug $Version running under perl $perl_version.
  649.  
  650. EOF
  651.  
  652.     if ($body) {
  653.     print REP $body;
  654.     } elsif ($usefile) {
  655.     open(F, "<$file")
  656.         or die "Unable to read report file from '$file': $!\n";
  657.     while (<F>) {
  658.         print REP $_
  659.     }
  660.     close(F) or die "Error closing '$file': $!";
  661.     } else {
  662.     if ($thanks) {
  663.         print REP <<'EOF';
  664.  
  665. -----------------------------------------------------------------
  666. [Please enter your thank-you message here]
  667.  
  668.  
  669.  
  670. [You're welcome to delete anything below this line]
  671. -----------------------------------------------------------------
  672. EOF
  673.     } else {
  674.         print REP <<'EOF';
  675.  
  676. -----------------------------------------------------------------
  677. [Please describe your issue here]
  678.  
  679.  
  680.  
  681. [Please do not change anything below this line]
  682. -----------------------------------------------------------------
  683. EOF
  684.     }
  685.     }
  686.     Dump(*REP);
  687.     close(REP) or die "Error closing report file: $!";
  688.  
  689.     # Set up an initial report fingerprint so we can compare it later
  690.     _fingerprint_lines_in_report();
  691.  
  692. } # sub Query
  693.  
  694. sub Dump {
  695.     local(*OUT) = @_;
  696.  
  697.     print OUT <<EFF;
  698. ---
  699. Flags:
  700.     category=$category
  701.     severity=$severity
  702. EFF
  703.  
  704.     if ($report_about_module ) { 
  705.         print OUT <<EFF;
  706.     module=$report_about_module
  707. EFF
  708.     }
  709.     if ($::opt_A) {
  710.     print OUT <<EFF;
  711.     ack=no
  712. EFF
  713.     }
  714.     print OUT <<EFF;
  715. ---
  716. EFF
  717.     print OUT "This perlbug was built using Perl $config_tag1\n",
  718.         "It is being executed now by  Perl $config_tag2.\n\n"
  719.     if $config_tag2 ne $config_tag1;
  720.  
  721.     print OUT <<EOF;
  722. Site configuration information for perl $perl_version:
  723.  
  724. EOF
  725.     if ($::Config{cf_by} and $::Config{cf_time}) {
  726.     print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n";
  727.     }
  728.     print OUT Config::myconfig;
  729.  
  730.     if (@patches) {
  731.     print OUT join "\n    ", "Locally applied patches:", @patches;
  732.     print OUT "\n";
  733.     };
  734.  
  735.     print OUT <<EOF;
  736.  
  737. ---
  738. \@INC for perl $perl_version:
  739. EOF
  740.     for my $i (@INC) {
  741.     print OUT "    $i\n";
  742.     }
  743.  
  744.     print OUT <<EOF;
  745.  
  746. ---
  747. Environment for perl $perl_version:
  748. EOF
  749.     my @env =
  750.         qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE);
  751.     push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
  752.     push @env, grep /^(?:PERL|LC_|LANG|CYGWIN)/, keys %ENV;
  753.     my %env;
  754.     @env{@env} = @env;
  755.     for my $env (sort keys %env) {
  756.     print OUT "    $env",
  757.         exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)',
  758.         "\n";
  759.     }
  760.     if ($verbose) {
  761.     print OUT "\nComplete configuration data for perl $perl_version:\n\n";
  762.     my $value;
  763.     foreach (sort keys %::Config) {
  764.         $value = $::Config{$_};
  765.         $value =~ s/'/\\'/g;
  766.         print OUT "$_='$value'\n";
  767.     }
  768.     }
  769. } # sub Dump
  770.  
  771. sub Edit {
  772.     # Edit the report
  773.     if ($usefile || $body) {
  774.     my $description = "Please make sure that the name of the editor you want to use is correct.";
  775.     my $entry = _prompt($description, 'Editor', $ed);
  776.     $ed = $entry unless $entry eq '';
  777.     }
  778.  
  779.     _edit_file($ed);
  780. }
  781.  
  782. sub _edit_file {
  783.     my $editor = shift;
  784.  
  785.     my $report_written = 0;
  786.  
  787.     while ( !$report_written ) {
  788.         if ($Is_MacOS) {
  789.             require ExtUtils::MakeMaker;
  790.             ExtUtils::MM_MacOS::launch_file($filename);
  791.             _prompt('', "Press Enter when done." );
  792.         } else {    # we're not on oldschool mac os
  793.             my $exit_status = system("$editor $filename");
  794.             if ($exit_status) {
  795.                 my $desc = <<EOF;
  796. The editor you chose ('$editor') could not be run!
  797.  
  798. If you mistyped its name, please enter it now, otherwise just press Enter.
  799. EOF
  800.                 my $entry = _prompt( $desc, 'Editor', $editor );
  801.                 if ( $entry ne "" ) {
  802.                     $editor = $entry;
  803.                     next;
  804.                 } else {
  805.                     paraprint <<EOF;
  806. You may want to save your report to a file, so you can edit and
  807. mail it later.
  808. EOF
  809.                     return;
  810.                 }
  811.             }
  812.         }
  813.         return if ( $ok and not $::opt_n ) || $body;
  814.  
  815.         # Check that we have a report that has some, eh, report in it.
  816.  
  817.         unless ( _fingerprint_lines_in_report() ) {
  818.             my $description = <<EOF;
  819. It looks like you didn't enter a report. You may [r]etry your edit
  820. or [c]ancel this report.
  821. EOF
  822.             my $action = _prompt( $description, "Action (Retry/Cancel) " );
  823.             if ( $action =~ /^[re]/i ) {    # <R>etry <E>dit
  824.                 next;
  825.             } elsif ( $action =~ /^[cq]/i ) {    # <C>ancel, <Q>uit
  826.                 Cancel();                        # cancel exits
  827.             }
  828.         }
  829.         # Ok. the user did what they needed to;
  830.         return;
  831.  
  832.     }
  833. }
  834.  
  835.  
  836. sub Cancel {
  837.     1 while unlink($filename);  # remove all versions under VMS
  838.     print "\nQuitting without sending your message.\n";
  839.     exit(0);
  840. }
  841.  
  842. sub NowWhat {
  843.     # Report is done, prompt for further action
  844.     if( !$::opt_S ) {
  845.     while(1) {
  846.         my $menu = <<EOF;
  847.  
  848.  
  849. You have finished composing your message. At this point, you have 
  850. a few options. You can:
  851.  
  852.     * [Se]end the message to $address$andcc, 
  853.     * [D]isplay the message on the screen,
  854.     * [R]e-edit the message
  855.     * Display or change the message's [su]bject
  856.     * Save the message to a [f]ile to mail at another time
  857.     * [Q]uit without sending a message
  858.  
  859. EOF
  860.       retry:
  861.         print $menu;
  862.         my $action =  _prompt('', "Action (Send/Display/Edit/Subject/Save to File)");;
  863.         print "\n";
  864.         if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
  865.             if ( SaveMessage() ) { exit }
  866.         } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
  867.         # Display the message
  868.         open(REP, "<$filename") or die "Couldn't open file '$filename': $!\n";
  869.         while (<REP>) { print $_ }
  870.         close(REP) or die "Error closing report file '$filename': $!";
  871.         } elsif ($action =~ /^su/i) { # <Su>bject
  872.         my $reply = _prompt( "Subject: $subject", "If the above subject is fine, press Enter. Otherwise, type a replacement now\nSubject");
  873.         if ($reply ne '') {
  874.             unless (TrivialSubject($reply)) {
  875.             $subject = $reply;
  876.             print "Subject: $subject\n";
  877.             }
  878.         }
  879.         } elsif ($action =~ /^se/i) { # <S>end
  880.         # Send the message
  881.         my $reply =  _prompt( "Are you certain you want to send this message?", 'Please type "yes" if you are','no');
  882.         if ($reply =~ /^yes$/) {
  883.             last;
  884.         } else {
  885.             paraprint <<EOF;
  886. You didn't type "yes", so your message has not yet been sent.
  887. EOF
  888.         }
  889.         } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit
  890.         # edit the message
  891.         Edit();
  892.         } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit
  893.         Cancel();
  894.         } elsif ($action =~ /^s/i) {
  895.         paraprint <<EOF;
  896. The command you entered was ambiguous. Please type "send", "save" or "subject".
  897. EOF
  898.         }
  899.     }
  900.     }
  901. } # sub NowWhat
  902.  
  903. sub TrivialSubject {
  904.     my $subject = shift;
  905.     if ($subject =~
  906.     /^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i ||
  907.     length($subject) < 4 ||
  908.     $subject !~ /\s/) {
  909.     print "\nThe subject you entered wasn't very descriptive. Please try again.\n\n";
  910.         return 1;
  911.     } else {
  912.     return 0;
  913.     }
  914. }
  915.  
  916. sub SaveMessage {
  917.     my $file_save = $outfile || "$progname.rep";
  918.     my $file = _prompt( '', "Name of file to save message in", $file_save );
  919.     save_message_to_disk($file) || return undef;
  920.     print "\n";
  921.     paraprint <<EOF;
  922. A copy of your message has been saved in '$file' for you to
  923. send to '$address' with your normal mail client.
  924. EOF
  925. }
  926.  
  927. sub Send {
  928.  
  929.     # Message has been accepted for transmission -- Send the message
  930.  
  931.     # on linux certain "mail" implementations won't accept the subject
  932.     # as "~s subject" and thus the Subject header will be corrupted
  933.     # so don't use Mail::Send to be safe
  934.     eval {
  935.         if ( $::HaveSend && !$Is_Linux && !$Is_OpenBSD ) {
  936.             _send_message_mailsend();
  937.         } elsif ($Is_VMS) {
  938.             _send_message_vms();
  939.         } else {
  940.             _send_message_sendmail();
  941.         }
  942.     };
  943.  
  944.     if ( my $error = $@ ) {
  945.         paraprint <<EOF;
  946. $0 has detected an error while trying to send your message: $error.
  947.  
  948. Your message may not have been sent. You will now have a chance to save a copy to disk.
  949. EOF
  950.         SaveMessage();
  951.         return;
  952.     }
  953.  
  954.     1 while unlink($filename);    # remove all versions under VMS
  955. }    # sub Send
  956.  
  957. sub Help {
  958.     print <<EOF;
  959.  
  960. This program is designed to help you generate and send bug reports
  961. (and thank-you notes) about perl5 and the modules which ship with it.
  962.  
  963. In most cases, you can just run "$0" interactively from a command
  964. line without any special arguments and follow the prompts.
  965.  
  966. Advanced usage:
  967.  
  968. $0  [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ]
  969.     [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h]
  970. $0  [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay]
  971.  
  972.  
  973. Options:
  974.  
  975.   -v    Include Verbose configuration data in the report
  976.   -f    File containing the body of the report. Use this to
  977.         quickly send a prepared message.
  978.   -F    File to output the resulting mail message to, instead of mailing.
  979.   -S    Send without asking for confirmation.
  980.   -a    Address to send the report to. Defaults to '$address'.
  981.   -c    Address to send copy of report to. Defaults to '$cc'.
  982.   -C    Don't send copy to administrator.
  983.   -s    Subject to include with the message. You will be prompted
  984.         if you don't supply one on the command line.
  985.   -b    Body of the report. If not included on the command line, or
  986.         in a file with -f, you will get a chance to edit the message.
  987.   -r    Your return address. The program will ask you to confirm
  988.         this if you don't give it here.
  989.   -e    Editor to use.
  990.   -t    Test mode. The target address defaults to '$testaddress'.
  991.   -T    Thank-you mode. The target address defaults to '$thanksaddress'.
  992.   -d    Data mode.  This prints out your configuration data, without mailing
  993.         anything. You can use this with -v to get more complete data.
  994.   -A    Don't send a bug received acknowledgement to the return address.
  995.   -ok   Report successful build on this system to perl porters
  996.         (use alone or with -v). Only use -ok if *everything* was ok:
  997.         if there were *any* problems at all, use -nok.
  998.   -okay As -ok but allow report from old builds.
  999.   -nok  Report unsuccessful build on this system to perl porters
  1000.         (use alone or with -v). You must describe what went wrong
  1001.         in the body of the report which you will be asked to edit.
  1002.   -nokay As -nok but allow report from old builds.
  1003.   -h    Print this help message.
  1004.  
  1005. EOF
  1006. }
  1007.  
  1008. sub filename {
  1009.     if ($::HaveTemp) {
  1010.     # Good. Use a secure temp file
  1011.     my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1);
  1012.     close($fh);
  1013.     return $filename;
  1014.     } else {
  1015.     # Bah. Fall back to doing things less securely.
  1016.     my $dir = File::Spec->tmpdir();
  1017.     $filename = "bugrep0$$";
  1018.     $filename++ while -e File::Spec->catfile($dir, $filename);
  1019.     $filename = File::Spec->catfile($dir, $filename);
  1020.     }
  1021. }
  1022.  
  1023. sub paraprint {
  1024.     my @paragraphs = split /\n{2,}/, "@_";
  1025.     for (@paragraphs) {   # implicit local $_
  1026.     s/(\S)\s*\n/$1 /g;
  1027.     write;
  1028.     print "\n";
  1029.     }
  1030. }
  1031.  
  1032. sub _prompt {
  1033.     my ($explanation, $prompt, $default) = (@_);
  1034.     if ($explanation) {
  1035.         print "\n\n";
  1036.         paraprint $explanation;
  1037.     }
  1038.     print $prompt. ($default ? " [$default]" :''). ": ";
  1039.     my $result = scalar(<>);
  1040.     chomp($result);
  1041.     $result =~ s/^\s*(.*?)\s*$/$1/s;
  1042.     if ($default && $result eq '') {
  1043.         return $default;
  1044.     } else {
  1045.         return $result;
  1046.     }
  1047. }
  1048.  
  1049. sub _build_header {
  1050.     my %attr = (@_);
  1051.  
  1052.     my $head = '';
  1053.     for my $header (keys %attr) {
  1054.         $head .= "$header: ".$attr{$header}."\n";
  1055.     }
  1056.     return $head;
  1057. }
  1058.  
  1059. sub _message_headers {
  1060.     my %headers = ( To => $address, Subject => $subject );
  1061.     $headers{'Cc'}         = $cc        if ($cc);
  1062.     $headers{'Message-Id'} = $messageid if ($messageid);
  1063.     $headers{'Reply-To'}   = $from      if ($from);
  1064.     return \%headers;
  1065. }
  1066.  
  1067. sub build_complete_message {
  1068.     my $content = _build_header(%{_message_headers()}) . "\n\n";
  1069.     open( REP, "<$filename" ) or die "Couldn't open file '$filename': $!\n";
  1070.     while (<REP>) { $content .= $_; }
  1071.     close(REP) or die "Error closing report file '$filename': $!";
  1072.     return $content;
  1073. }
  1074.  
  1075. sub save_message_to_disk {
  1076.     my $file = shift;
  1077.  
  1078.         open OUTFILE, ">$file" or do { warn  "Couldn't open '$file': $!\n"; return undef};
  1079.         print OUTFILE build_complete_message();
  1080.         close(OUTFILE) or do { warn  "Error closing $file: $!"; return undef };
  1081.         print "\nMessage saved.\n";
  1082.         return 1;
  1083. }
  1084.  
  1085. sub _send_message_vms {
  1086.     if (   ( $address =~ /@/ and $address !~ /^\w+%"/ )
  1087.         or ( $cc =~ /@/ and $cc !~ /^\w+%"/ ) ) {
  1088.         my $prefix;
  1089.         foreach ( qw[ IN MX SMTP UCX PONY WINS ], '' ) {
  1090.             $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"};
  1091.         }
  1092.         $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/;
  1093.         $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/;
  1094.     }
  1095.     $subject =~ s/"/""/g;
  1096.     $address =~ s/"/""/g;
  1097.     $cc      =~ s/"/""/g;
  1098.     my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]);
  1099.     if ($sts) {
  1100.         die "Can't spawn off mail (leaving bug report in $filename): $sts";
  1101.     }
  1102. }
  1103.  
  1104. sub _send_message_mailsend {
  1105.     my $msg = Mail::Send->new();
  1106.     my %headers = %{_message_headers()};
  1107.     for my $key ( keys %headers) {
  1108.         $msg->add($key => $headers{$key});
  1109.     }
  1110.  
  1111.     $fh = $msg->open;
  1112.     open(REP, "<$filename") or die "Couldn't open '$filename': $!\n";
  1113.     while (<REP>) { print $fh $_ }
  1114.     close(REP) or die "Error closing $filename: $!";
  1115.     $fh->close;
  1116.  
  1117.     print "\nMessage sent.\n";
  1118. }
  1119.  
  1120. sub _probe_for_sendmail {
  1121.     my $sendmail = "";
  1122.     for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) {
  1123.         $sendmail = $_, last if -e $_;
  1124.     }
  1125.     if ( $^O eq 'os2' and $sendmail eq "" ) {
  1126.         my $path = $ENV{PATH};
  1127.         $path =~ s:\\:/:;
  1128.         my @path = split /$Config{'path_sep'}/, $path;
  1129.         for (@path) {
  1130.             $sendmail = "$_/sendmail",     last if -e "$_/sendmail";
  1131.             $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe";
  1132.         }
  1133.     }
  1134.     return $sendmail;
  1135. }
  1136.  
  1137. sub _send_message_sendmail {
  1138.     my $sendmail = _probe_for_sendmail();
  1139.     unless ($sendmail) {
  1140.         paraprint(<<"EOF"), die "\n";
  1141. It appears that there is no program which looks like "sendmail" on
  1142. your system and that the Mail::Send library from CPAN isn't available.
  1143. Because of this, there's no easy way to automatically send your
  1144. message.
  1145.  
  1146. A copy of your message has been saved in '$filename' for you to
  1147. send to '$address' with your normal mail client.
  1148. EOF
  1149.     }
  1150.  
  1151.     open( SENDMAIL, "|$sendmail -t -oi" )
  1152.         || die "'|$sendmail -t -oi' failed: $!";
  1153.     print SENDMAIL build_complete_message();
  1154.     if ( close(SENDMAIL) ) {
  1155.         print "\nMessage sent\n";
  1156.     } else {
  1157.         warn "\nSendmail returned status '", $? >> 8, "'\n";
  1158.     }
  1159. }
  1160.  
  1161.  
  1162.  
  1163. # a strange way to check whether any significant editing
  1164. # has been done: check whether any new non-empty lines
  1165. # have been added.
  1166.  
  1167. sub _fingerprint_lines_in_report {
  1168.     my $new_lines = 0;
  1169.     # read in the report template once so that
  1170.     # we can track whether the user does any editing.
  1171.     # yes, *all* whitespace is ignored.
  1172.  
  1173.     open(REP, "<$filename") or die "Unable to open report file '$filename': $!\n";
  1174.     while (my $line = <REP>) {
  1175.         $line =~ s/\s+//g;
  1176.         $new_lines++ if (!$REP{$line});
  1177.  
  1178.     }
  1179.     close(REP) or die "Error closing report file '$filename': $!";
  1180.     # returns the number of lines with content that wasn't there when last we looked
  1181.     return $new_lines;
  1182. }
  1183.  
  1184.  
  1185.  
  1186. format STDOUT =
  1187. ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
  1188. $_
  1189. .
  1190.  
  1191. __END__
  1192.  
  1193. =head1 NAME
  1194.  
  1195. perlbug - how to submit bug reports on Perl
  1196.  
  1197. =head1 SYNOPSIS
  1198.  
  1199. B<perlbug>
  1200.  
  1201. B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]>
  1202. S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]>
  1203. S<[ B<-r> I<returnaddress> ]>
  1204. S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]>
  1205. S<[ B<-S> ]> S<[ B<-t> ]>  S<[ B<-d> ]>  S<[ B<-A> ]>  S<[ B<-h> ]> S<[ B<-T> ]>
  1206.  
  1207. B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]>
  1208.  S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
  1209.  
  1210. B<perlthanks>
  1211.  
  1212. =head1 DESCRIPTION
  1213.  
  1214.  
  1215. This program is designed to help you generate and send bug reports
  1216. (and thank-you notes) about perl5 and the modules which ship with it.
  1217.  
  1218. In most cases, you can just run it interactively from a command
  1219. line without any special arguments and follow the prompts.
  1220.  
  1221. If you have found a bug with a non-standard port (one that was not
  1222. part of the I<standard distribution>), a binary distribution, or a
  1223. non-core module (such as Tk, DBI, etc), then please see the
  1224. documentation that came with that distribution to determine the
  1225. correct place to report bugs.
  1226.  
  1227. If you are unable to send your report using B<perlbug> (most likely
  1228. because your system doesn't have a way to send mail that perlbug
  1229. recognizes), you may be able to use this tool to compose your report
  1230. and save it to a file which you can then send to B<perlbug@perl.org>
  1231. using your regular mail client.
  1232.  
  1233. In extreme cases, B<perlbug> may not work well enough on your system
  1234. to guide you through composing a bug report. In those cases, you
  1235. may be able to use B<perlbug -d> to get system configuration
  1236. information to include in a manually composed bug report to
  1237. B<perlbug@perl.org>.
  1238.  
  1239.  
  1240. When reporting a bug, please run through this checklist:
  1241.  
  1242. =over 4
  1243.  
  1244. =item What version of Perl you are running?
  1245.  
  1246. Type C<perl -v> at the command line to find out.
  1247.  
  1248. =item Are you running the latest released version of perl?
  1249.  
  1250. Look at http://www.perl.org/ to find out.  If you are not using the
  1251. latest released version, please try to replicate your bug on the
  1252. latest stable release.
  1253.  
  1254. Note that reports about bugs in old versions of Perl, especially
  1255. those which indicate you haven't also tested the current stable
  1256. release of Perl, are likely to receive less attention from the
  1257. volunteers who build and maintain Perl than reports about bugs in
  1258. the current release.
  1259.  
  1260. This tool isn't apropriate for reporting bugs in any version
  1261. prior to Perl 5.0.
  1262.  
  1263. =item Are you sure what you have is a bug?
  1264.  
  1265. A significant number of the bug reports we get turn out to be
  1266. documented features in Perl.  Make sure the issue you've run into
  1267. isn't intentional by glancing through the documentation that comes
  1268. with the Perl distribution.
  1269.  
  1270. Given the sheer volume of Perl documentation, this isn't a trivial
  1271. undertaking, but if you can point to documentation that suggests
  1272. the behaviour you're seeing is I<wrong>, your issue is likely to
  1273. receive more attention. You may want to start with B<perldoc>
  1274. L<perltrap> for pointers to common traps that new (and experienced)
  1275. Perl programmers run into.
  1276.  
  1277. If you're unsure of the meaning of an error message you've run
  1278. across, B<perldoc> L<perldiag> for an explanation.  If the message
  1279. isn't in perldiag, it probably isn't generated by Perl.  You may
  1280. have luck consulting your operating system documentation instead.
  1281.  
  1282. If you are on a non-UNIX platform B<perldoc> L<perlport>, as some
  1283. features may be unimplemented or work differently.
  1284.  
  1285. You may be able to figure out what's going wrong using the Perl
  1286. debugger.  For information about how to use the debugger B<perldoc>
  1287. L<perldebug>.
  1288.  
  1289. =item Do you have a proper test case?
  1290.  
  1291. The easier it is to reproduce your bug, the more likely it will be
  1292. fixed -- if nobody can duplicate your problem, it probably won't be 
  1293. addressed.
  1294.  
  1295. A good test case has most of these attributes: short, simple code;
  1296. few dependencies on external commands, modules, or libraries; no
  1297. platform-dependent code (unless it's a platform-specific bug);
  1298. clear, simple documentation.
  1299.  
  1300. A good test case is almost always a good candidate to be included in
  1301. Perl's test suite.  If you have the time, consider writing your test case so
  1302. that it can be easily included into the standard test suite.
  1303.  
  1304. =item Have you included all relevant information?
  1305.  
  1306. Be sure to include the B<exact> error messages, if any.
  1307. "Perl gave an error" is not an exact error message.
  1308.  
  1309. If you get a core dump (or equivalent), you may use a debugger
  1310. (B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug
  1311. report.  
  1312.  
  1313. NOTE: unless your Perl has been compiled with debug info
  1314. (often B<-g>), the stack trace is likely to be somewhat hard to use
  1315. because it will most probably contain only the function names and not
  1316. their arguments.  If possible, recompile your Perl with debug info and
  1317. reproduce the crash and the stack trace.
  1318.  
  1319. =item Can you describe the bug in plain English?
  1320.  
  1321. The easier it is to understand a reproducible bug, the more likely
  1322. it will be fixed.  Any insight you can provide into the problem
  1323. will help a great deal.  In other words, try to analyze the problem
  1324. (to the extent you can) and report your discoveries.
  1325.  
  1326. =item Can you fix the bug yourself?
  1327.  
  1328. A bug report which I<includes a patch to fix it> will almost
  1329. definitely be fixed.  When sending a patch, please use the C<diff>
  1330. program with the C<-u> option to generate "unified" diff files.
  1331. Bug reports with patches are likely to receive significantly more
  1332. attention and interest than those without patches.
  1333.  
  1334. Your patch may be returned with requests for changes, or requests for more
  1335. detailed explanations about your fix.
  1336.  
  1337. Here are a few hints for creating high-quality patches:
  1338.  
  1339. Make sure the patch is not reversed (the first argument to diff is
  1340. typically the original file, the second argument your changed file).
  1341. Make sure you test your patch by applying it with the C<patch>
  1342. program before you send it on its way.  Try to follow the same style
  1343. as the code you are trying to patch.  Make sure your patch really
  1344. does work (C<make test>, if the thing you're patching is covered
  1345. by Perl's test suite).
  1346.  
  1347. =item Can you use C<perlbug> to submit the report?
  1348.  
  1349. B<perlbug> will, amongst other things, ensure your report includes
  1350. crucial information about your version of perl.  If C<perlbug> is
  1351. unable to mail your report after you have typed it in, you may have
  1352. to compose the message yourself, add the output produced by C<perlbug
  1353. -d> and email it to B<perlbug@perl.org>.  If, for some reason, you
  1354. cannot run C<perlbug> at all on your system, be sure to include the
  1355. entire output produced by running C<perl -V> (note the uppercase V).
  1356.  
  1357. Whether you use C<perlbug> or send the email manually, please make
  1358. your Subject line informative.  "a bug" is not informative.  Neither
  1359. is "perl crashes" nor is "HELP!!!".  These don't help.  A compact
  1360. description of what's wrong is fine.
  1361.  
  1362. =item Can you use C<perlbug> to submit a thank-you note?
  1363.  
  1364. Yes, you can do this by either using the C<-T> option, or by invoking
  1365. the program as C<perlthanks>. Thank-you notes are good. It makes people
  1366. smile. 
  1367.  
  1368. =back
  1369.  
  1370. Having done your bit, please be prepared to wait, to be told the
  1371. bug is in your code, or possibly to get no reply at all.  The
  1372. volunteers who maintain Perl are busy folks, so if your problem is
  1373. an obvious bug in your own code, is difficult to understand or is
  1374. a duplicate of an existing report, you may not receive a personal
  1375. reply.
  1376.  
  1377. If it is important to you that your bug be fixed, do monitor the
  1378. perl5-porters@perl.org mailing list and the commit logs to development
  1379. versions of Perl, and encourage the maintainers with kind words or
  1380. offers of frosty beverages.  (Please do be kind to the maintainers.
  1381. Harassing or flaming them is likely to have the opposite effect of
  1382. the one you want.)
  1383.  
  1384. Feel free to update the ticket about your bug on http://rt.perl.org
  1385. if a new version of Perl is released and your bug is still present.
  1386.  
  1387. =head1 OPTIONS
  1388.  
  1389. =over 8
  1390.  
  1391. =item B<-a>
  1392.  
  1393. Address to send the report to.  Defaults to B<perlbug@perl.org>.
  1394.  
  1395. =item B<-A>
  1396.  
  1397. Don't send a bug received acknowledgement to the reply address.
  1398. Generally it is only a sensible to use this option if you are a
  1399. perl maintainer actively watching perl porters for your message to
  1400. arrive.
  1401.  
  1402. =item B<-b>
  1403.  
  1404. Body of the report.  If not included on the command line, or
  1405. in a file with B<-f>, you will get a chance to edit the message.
  1406.  
  1407. =item B<-C>
  1408.  
  1409. Don't send copy to administrator.
  1410.  
  1411. =item B<-c>
  1412.  
  1413. Address to send copy of report to.  Defaults to the address of the
  1414. local perl administrator (recorded when perl was built).
  1415.  
  1416. =item B<-d>
  1417.  
  1418. Data mode (the default if you redirect or pipe output).  This prints out
  1419. your configuration data, without mailing anything.  You can use this
  1420. with B<-v> to get more complete data.
  1421.  
  1422. =item B<-e>
  1423.  
  1424. Editor to use.
  1425.  
  1426. =item B<-f>
  1427.  
  1428. File containing the body of the report.  Use this to quickly send a
  1429. prepared message.
  1430.  
  1431. =item B<-F>
  1432.  
  1433. File to output the results to instead of sending as an email. Useful
  1434. particularly when running perlbug on a machine with no direct internet
  1435. connection.
  1436.  
  1437. =item B<-h>
  1438.  
  1439. Prints a brief summary of the options.
  1440.  
  1441. =item B<-ok>
  1442.  
  1443. Report successful build on this system to perl porters. Forces B<-S>
  1444. and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only
  1445. prompts for a return address if it cannot guess it (for use with
  1446. B<make>). Honors return address specified with B<-r>.  You can use this
  1447. with B<-v> to get more complete data.   Only makes a report if this
  1448. system is less than 60 days old.
  1449.  
  1450. =item B<-okay>
  1451.  
  1452. As B<-ok> except it will report on older systems.
  1453.  
  1454. =item B<-nok>
  1455.  
  1456. Report unsuccessful build on this system.  Forces B<-C>.  Forces and
  1457. supplies a value for B<-s>, then requires you to edit the report
  1458. and say what went wrong.  Alternatively, a prepared report may be
  1459. supplied using B<-f>.  Only prompts for a return address if it
  1460. cannot guess it (for use with B<make>). Honors return address
  1461. specified with B<-r>.  You can use this with B<-v> to get more
  1462. complete data.  Only makes a report if this system is less than 60
  1463. days old.
  1464.  
  1465. =item B<-nokay>
  1466.  
  1467. As B<-nok> except it will report on older systems.
  1468.  
  1469. =item B<-r>
  1470.  
  1471. Your return address.  The program will ask you to confirm its default
  1472. if you don't use this option.
  1473.  
  1474. =item B<-S>
  1475.  
  1476. Send without asking for confirmation.
  1477.  
  1478. =item B<-s>
  1479.  
  1480. Subject to include with the message.  You will be prompted if you don't
  1481. supply one on the command line.
  1482.  
  1483. =item B<-t>
  1484.  
  1485. Test mode.  The target address defaults to B<perlbug-test@perl.org>.
  1486.  
  1487. =item B<-T>
  1488.  
  1489. Send a thank-you note instead of a bug report. 
  1490.  
  1491. =item B<-v>
  1492.  
  1493. Include verbose configuration data in the report.
  1494.  
  1495. =back
  1496.  
  1497. =head1 AUTHORS
  1498.  
  1499. Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently
  1500. I<doc>tored by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>),
  1501. Tom Christiansen (E<lt>tchrist@perl.comE<gt>), Nathan Torkington
  1502. (E<lt>gnat@frii.comE<gt>), Charles F. Randall (E<lt>cfr@pobox.comE<gt>),
  1503. Mike Guy (E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop
  1504. (E<lt>domo@computer.orgE<gt>), Hugo van der Sanden (E<lt>hv@crypt.org<gt>),
  1505. Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor
  1506. (E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>,
  1507. Richard Foley (E<lt>richard.foley@rfi.netE<gt>), and Jesse Vincent
  1508. (E<lt>jesse@bestpractical.com<gt>).
  1509.  
  1510. =head1 SEE ALSO
  1511.  
  1512. perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1),
  1513. diff(1), patch(1), dbx(1), gdb(1)
  1514.  
  1515. =head1 BUGS
  1516.  
  1517. None known (guess what must have been used to report them?)
  1518.  
  1519. =cut
  1520.  
  1521.